MacTech 1 to 12

home *** CD-ROM | disk | FTP | other *** search

/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 07 - 1991 / 07.12 Dec 91 / Transfer Menu Code / Transfer.p < prev next >

Wrap

Text File | 1988-12-28 | 21.2 KB | 935 lines | [TEXT/MPS ]

(******************************************************************* Transfer.p Demo of a dynamic Transfer menu. (c) 1988, by Clifford Story & Attic Software *******************************************************************) program Transfer; (******************************************************************) uses memtypes, quickdraw, osintf, toolintf, packintf, Common; (******************************************************************* Program constants: *******************************************************************) const applenum = 1001; aboutitem = 1; atticitem = 2; filenum = 1002; quititem = 1; editnum = 1003; undoitem = 1; cutitem = 3; copyitem = 4; pasteitem = 5; clearitem = 6; transnum = 1004; transitem = 1; edititem = 2; messagedialog = 1001; editdialog = 1002; editlist = 4; editdelete = 5; editline = 6; (******************************************************************* Program variables: *******************************************************************) var APPLEMENU : MenuHandle; FILEMENU : MenuHandle; EDITMENU : MenuHandle; TRANSMENU : MenuHandle; DONE : logical; JEVENT : logical; HARDDISK : logical; DEFVOL : integer; MENUHEIGHT : integer; MAINEVENT : EventRecord; (******************************************************************) procedure _datainit; external; (******************************************************************) {$R-} {$SC+} (******************************************************************) procedure panic; begin ExitToShell; end; (******************************************************************) procedure centerdialog(thetype : OSType; theid : integer); var thehandle : AlertTHndl; begin thehandle := AlertTHndl(GetResource(thetype, theid)); HLock(Handle(thehandle)); with thehandle^^ do begin with boundsRect do SetRect(boundsRect, 0, 0, right - left, bottom - top); with screenBits.bounds, boundsRect.botright do OffsetRect(boundsRect, (right - left - h) div 2, (bottom - top - v + 2 * MENUHEIGHT) div 3); end; HUnlock(Handle(thehandle)); end; (******************************************************************) procedure message(what : Str255); var dummy : integer; begin InitCursor; ParamText(what, '', '', ''); centerdialog('ALRT', messagedialog); dummy := Alert(messagedialog, nil); end; (******************************************************************) procedure initmac; begin MaxApplZone; InitGraf(@thePort); InitFonts; InitWindows; InitCursor; InitMenus; TEInit; InitDialogs(@panic); UnloadSeg(@_datainit); end; (******************************************************************) procedure setupmenus; begin APPLEMENU := GetMenu(applenum); AddResMenu(APPLEMENU, 'DRVR'); InsertMenu(APPLEMENU, 0); FILEMENU := GetMenu(filenum); InsertMenu(FILEMENU, 0); EDITMENU := GetMenu(editnum); InsertMenu(EDITMENU, 0); TRANSMENU := GetMenu(transnum); InsertMenu(TRANSMENU, 0); DrawMenuBar; end; (******************************************************************* initglobals ----------- This routine runs before anything might change the default volume, so the GetVol call will return the volume reference number of the volume the Transfer application is launched from. *******************************************************************) procedure initglobals; var index : integer; begin for index := 1 to 10 do MoreMasters; if BitTst(Ptr(rom85), 0) then begin MENUHEIGHT := 20; JEVENT := false; end else begin MENUHEIGHT := shortpointer(mbarheight)^; JEVENT := (NGetTrapAddress($A860, ToolTrap) <> NGetTrapAddress($A89F, ToolTrap)); end; if GetVol(nil, DEFVOL) <> noErr then DEFVOL := 0; DONE := false; end; (******************************************************************) procedure clickapplemenu(theitem : integer); var itemname : Str255; savedport : GrafPtr; dummy : integer; newport : GrafPort; thepicture : PicHandle; therect : Rect; begin if theitem > 3 then begin GetItem(APPLEMENU, theitem, itemname); GetPort(savedport); dummy := OpenDeskAcc(itemname); SetPort(savedport); end else if theitem < 3 then begin InitCursor; GetPort(savedport); OpenPort(@newport); SetPort(@newport); thepicture := PicHandle(GetResource('PICT', 1000 + theitem)); with thepicture^^.picFrame do SetRect(therect, 0, 0, right - left, bottom - top); with screenBits.bounds, therect.botright do OffsetRect(therect, (right - left - h) div 2, (bottom - top - v) div 3); DrawPicture(thepicture, therect); repeat until Button; ClosePort(@newport); DrawMenuBar; PaintBehind(WindowPeek(FrontWindow), RgnHandle(longpointer(grayrgn)^)); SetPort(savedport); FlushEvents(everyEvent, 0); end; end; (******************************************************************* doquit ------ This routine closes all desk accessory windows before a quit or transfer. DONE should remain false in event of a transfer, so the program can continue if the transfer fails. *******************************************************************) procedure doquit(quitting : logical); var thewindow : windowpeek; begin thewindow := windowpeek(frontwindow); while thewindow <> nil do with thewindow^ do begin if windowkind < 0 then closedeskacc(windowkind); thewindow := nextwindow; end; if quitting then DONE := true; end; (******************************************************************* launch ------ The Segment Loader's _launch trap is register-based; it expects A0 to contain a pointer to a launch record. This glue routine builds the record on the stack, moves the stack pointer to A0, then calls the trap. *******************************************************************) procedure launch(config : integer; name : Ptr); inline $204F, $A9F2; { movea.l A7,A0 _launch } (******************************************************************* transferappl ------------ This routine launches the application “name”, from the directory and volume specified. First, it tells _launch where to look. If the program is running under MFS, this is simply the volume (no real folders). Under HFS, it opens a working directory and sets the volume to that. Next, it makes sure the application is there, with a call to GetFInfo (first converting the str31 to an Str255 first, to satisfy Pascal's type rules). If it is, then it launchs it. If the application gets launched successfully, then this program is finished. If it is still running, then something must have gone wrong. *******************************************************************) procedure transferappl(name : str31; volume : integer; directory : long); const procID = $54524E53; var thestring : Str255; anerror : integer; theblock : WDPBRec; theinfo : FInfo; begin BlockMove(@name, @thestring, 32); if shortpointer(fsfcblen)^ = -1 then anerror := SetVol(nil, volume) else with theblock do begin ioCompletion := nil; ioNamePtr := nil; ioVRefNum := volume; ioWDProcID := procID; ioWDDirID := directory; anerror := PBOpenWD(@theblock, false); if anerror = noErr then anerror := SetVol(nil, ioVRefNum) end; if anerror = noErr then begin anerror := GetFInfo(thestring, 0, theinfo); if (anerror = noErr) and (theinfo.fdType = 'APPL') then begin doquit(false); launch(0, @thestring); end; end; message(concat('Sorry! Couldn''t find “', thestring, '”.')); end; (******************************************************************* diskfilter ---------- This is a hack to spot removeable volumes. If the volume is removeable, the the “Eject” button is active; otherwise, the button is dimmed. So look at the button to determine the type of the volume. *******************************************************************) function diskfilter(theitem : integer; thedialog : DialogPtr) : integer; var thetype : integer; thehandle : Handle; therect : Rect; begin if theitem = getOpen then begin GetDItem(thedialog, getEject, thetype, thehandle, therect); HARDDISK := ControlHandle(thehandle)^^.contrlhilite = 255; end; diskfilter := theitem; end; (******************************************************************* newtransfer ----------- This routine puts up an SFGetFile dialog and transfers to the chosen application. It gets the application's volume and directory from low-memory globals, and the name from the SFReply record, then calls the “transferappl” routine above. In between, it may record the application on the Transfer menu (to be displayed the next time the program is run). It will do this if either the application's volume is not removeable, or if the application is on the same volume as this program. The idea is that the target application should not be separated from the program if it's to be added to the Transfer menu. The actual addition is a little bit tricky, since the menu should be in alphabetical order. *******************************************************************) procedure newtransfer; var thepoint : Point; thelist : SFTypeList; thereply : SFReply; newappl : tline; thehandle : thandle; thecount : integer; index : integer; begin with screenBits.bounds do SetPt(thepoint, (right - left - 348) div 2, (bottom - top - 200 + 2 * MENUHEIGHT) div 3); thelist[0] := 'APPL'; SFGetFile(thepoint, '', nil, 1, thelist, @diskfilter, thereply); if thereply.good then begin with newappl do begin volume := - shortpointer(sfsavedisk)^; directory := longpointer(curdirstore)^; BlockMove(@thereply.fname, @name, 32); end; if HARDDISK or (newappl.volume = DEFVOL) then begin thehandle := thandle(GetResource('TRNS', 1001)); thecount := thehandle^^.count + 1; thehandle^^.count := thecount; SetHandleSize(Handle(thehandle), 2 + thecount * sizeof(tline)); HLock(Handle(thehandle)); with thehandle^^ do begin for index := 1 to thecount do if (IUCompString(appl[index].name, thereply.fname) > 0) then begin thecount := index; leave; end; BlockMove(@appl[thecount], @appl[thecount + 1], GetHandleSize(Handle(thehandle)) - long(@appl[thecount + 1]) + long(thehandle^)); BlockMove(@newappl, @appl[thecount], sizeof(tline)); ChangedResource(Handle(thehandle)); WriteResource(Handle(thehandle)); end; HUnlock(Handle(thehandle)); end; with newappl do transferappl(name, volume, directory); end; end; (******************************************************************* deleteappl ---------- This routine chops an item out of the Transfer menu. *******************************************************************) procedure deleteappl(thehandle : thandle; theappl : integer); begin HLock(Handle(thehandle)); with thehandle^^ do begin count := count - 1; BlockMove(@appl[theappl + 1], @appl[theappl], GetHandleSize(Handle(thehandle)) - long(@appl[theappl + 1]) + long(thehandle^)); end; HUnlock(Handle(thehandle)); SetHandleSize(Handle(thehandle), GetHandleSize(Handle(thehandle)) - sizeof(tline)); end; (******************************************************************* dotheok ------- Highlight the “ok” button. *******************************************************************) procedure dotheok(thewindow : WindowPtr; theitem : integer); var thetype : integer; thehandle : Handle; therect : Rect; begin GetDItem(thewindow, ok, thetype, thehandle, therect); PenSize(3, 3); InsetRect(therect, -4, -4); FrameRoundRect(therect, 16, 16); PenSize(1, 1); end; (******************************************************************* dothelist --------- Draw the dialog's list. *******************************************************************) procedure dothelist(thewindow : WindowPtr; theitem : integer); var thetype : integer; thehandle : Handle; therect : Rect; begin LUpdate(thewindow^.visRgn, ListHandle(GetWRefCon(thewindow))); GetDItem(thewindow, theitem, thetype, thehandle, therect); InsetRect(therect, - 1, - 1); FrameRect(therect); end; (******************************************************************* dotheline --------- Draw a dividing line in the dialog. *******************************************************************) procedure dotheline(thewindow : WindowPtr; theitem : integer); var thetype : integer; thehandle : Handle; therect : Rect; begin GetDItem(thewindow, theitem, thetype, thehandle, therect); MoveTo(therect.left, therect.top); LineTo(therect.right, therect.top); end; (******************************************************************* editfilter ---------- This routine supports the usual keyboard equivalents for dialog buttons, as well as “D” for the “Delete” button. If the mouse is clicked in the list, the click is passed to LClick. *******************************************************************) function editfilter(thedialog : DialogPtr; var theevent : EventRecord; var theitem : integer): logical; const enterkey = 3; returnkey = 13; periodkey = 46; var thekey : integer; thepoint : Point; thetype : integer; thehandle : Handle; therect : Rect; begin editfilter := false; if theevent.what = keyDown then begin thekey := BitAnd(charCodeMask, theevent.message); if (thekey = enterkey) or (thekey = returnkey) then begin theitem := ok; editfilter := true; end else if thekey = periodkey then begin theitem := cancel; editfilter := true; end else if (thekey = ord('d')) or (thekey = ord('D')) then begin theitem := editdelete; editfilter := true; end; end else if theevent.what = mouseDown then begin thepoint := theevent.where; GlobalToLocal(thepoint); GetDItem(thedialog, editlist, thetype, thehandle, therect); if PtInRect(thepoint, therect) then begin editfilter := true; if LClick(thepoint, 0, ListHandle(GetWRefCon(thedialog))) then ; theitem := editlist; end; end; end; (******************************************************************* edittransfer ------------ This routine puts up a dialog with a list of the applications on the menu. Note that the list uses a custom LDEF. While the dialog is up, clicking the “Delete” button will delete the selected item from the list and the “TRNS” resource. This change can be cancelled, however; if the dialog is dismissed by clicking “cancel”, then the resource with the deletions is released; the next time it is used, the Resource Manager will load the un-deleted version from disk. If the dialog is dismissed by clicking the “ok” button, then the resource is updated. The menu just shrank, so its dimensions must be recalculated with CalcMenuSize. *******************************************************************) procedure edittransfer; var savedport : GrafPtr; thedialog : DialogPtr; therecord : DialogRecord; thetype : integer; thehandle : Handle; therect : Rect; bounds : Rect; thepoint : Point; thethandle : thandle; thelist : ListHandle; choice : integer; begin GetPort(savedport); centerdialog('DLOG', editdialog); thedialog := GetNewDialog(editdialog, @therecord, pointer(-1)); SetPort(thedialog); GetDItem(thedialog, themask, thetype, thehandle, therect); thehandle := Handle(@dotheok); SetDItem(thedialog, themask, userItem, thehandle, therect); GetDItem(thedialog, editlist, thetype, thehandle, therect); thehandle := Handle(@dothelist); SetDItem(thedialog, editlist, userItem, thehandle, therect); therect.right := therect.right - 15; thethandle := thandle(GetResource('TRNS', 1001)); SetRect(bounds, 0, 0, 1, thethandle^^.count); SetPt(thepoint, therect.right - therect.left, 16); thelist := LNew(therect, bounds, thepoint, 1001, thedialog, true, false, false, true); SetWRefCon(thedialog, long(thelist)); GetDItem(thedialog, editline, thetype, thehandle, therect); thehandle := Handle(@dotheline); SetDItem(thedialog, editline, userItem, thehandle, therect); ShowWindow(thedialog); repeat ModalDialog(@editfilter, choice); if choice = editdelete then begin SetPt(thepoint, 0, 0); if LGetSelect(true, thepoint, thelist) then begin deleteappl(thethandle, thepoint.v + 1); LDelRow(1, thepoint.v, thelist); end; end; until (choice = ok) or (choice = cancel); if choice = cancel then ReleaseResource(Handle(thethandle)) else begin ChangedResource(Handle(thethandle)); WriteResource(Handle(thethandle)); CalcMenuSize(TRANSMENU); end; LDispose(thelist); CloseDialog(thedialog); SetPort(savedport); end; (******************************************************************* clicktransfermenu ----------------- This routine handles selections from the Transfer menu. The “Transfer...” and “Edit Menu...” commands are performed in separate routines above. Transfers to applications on the menu are done by the “Transfer” routine. If everything works, control never returns; if it does, then an error occurred, so delete that item from the menu. *******************************************************************) procedure clicktransfermenu(theitem : integer); var thehandle : thandle; thecount : integer; begin case theitem of transitem : newtransfer; edititem : edittransfer; otherwise thehandle := thandle(GetResource('TRNS', 1001)); HLock(Handle(thehandle)); with thehandle^^.appl[theitem - 3] do transferappl(name, volume, directory); deleteappl(thehandle, theitem - 3); ChangedResource(Handle(thehandle)); WriteResource(Handle(thehandle)); CalcMenuSize(TRANSMENU); end; end; (******************************************************************) procedure checkmenu; begin if FrontWindow = nil then DisableItem(EDITMENU, 0) else EnableItem(EDITMENU, 0); end; (******************************************************************) procedure clickinmenu; var choice : long; begin checkmenu; choice := MenuSelect(MAINEVENT.where); case HiWord(choice) of applenum : clickapplemenu(LoWord(choice)); filenum : doquit(true); editnum : if SystemEdit(LoWord(choice) - 1) then; transnum : clicktransfermenu(LoWord(choice)); end; HiliteMenu(0); end; (******************************************************************) procedure aclick; var location : integer; thewindow : WindowPtr; begin location := FindWindow(MAINEVENT.where, thewindow); case location of inDesk : SysBeep(1); inMenuBar : clickinmenu; inSysWindow : SystemClick(MAINEVENT, thewindow); end; end; (******************************************************************) procedure akey; var charcode : integer; choice : long; begin if BitAnd(MAINEVENT.modifiers, cmdKey) <> 0 then begin charcode := BitAnd(MAINEVENT.message, charCodeMask); checkmenu; choice := MenuKey(chr(charcode)); if choice <> 0 then begin case HiWord(choice) of applenum : clickapplemenu(LoWord(choice)); filenum : doquit(true); editnum : if SystemEdit(LoWord(choice) - 1) then; transnum : clicktransfermenu(LoWord(choice)); end; HiliteMenu(0); end; end; end; (******************************************************************) procedure mainloop; var dummy : logical; begin repeat if JEVENT then dummy := waitnextevent(everyEvent, MAINEVENT, GetCaretTime, nil) else begin SystemTask; dummy := GetNextEvent(everyEvent, MAINEVENT); end; if dummy then begin case MAINEVENT.what of mouseDown : aclick; keyDown : akey; end; end; until DONE; end; (******************************************************************) begin initmac; setupmenus; initglobals; mainloop; end. (******************************************************************)